home *** CD-ROM | disk | FTP | other *** search
/ Clickx 115 / Clickx 115.iso / software / tools / windows / tails-i386-0.16.iso / live / filesystem.squashfs / usr / share / perl5 / PPI / Lexer.pm < prev    next >
Encoding:
Perl POD Document  |  2010-07-06  |  41.6 KB  |  1,588 lines
  1. package PPI::Lexer;
  2.  
  3. =pod
  4.  
  5. =head1 NAME
  6.  
  7. PPI::Lexer - The PPI Lexer
  8.  
  9. =head1 SYNOPSIS
  10.  
  11.   use PPI;
  12.   
  13.   # Create a new Lexer
  14.   my $Lexer = PPI::Lexer->new;
  15.   
  16.   # Build a PPI::Document object from a Token stream
  17.   my $Tokenizer = PPI::Tokenizer->load('My/Module.pm');
  18.   my $Document = $Lexer->lex_tokenizer($Tokenizer);
  19.   
  20.   # Build a PPI::Document object for some raw source
  21.   my $source = "print 'Hello World!'; kill(Humans->all);";
  22.   $Document = $Lexer->lex_source($source);
  23.   
  24.   # Build a PPI::Document object for a particular file name
  25.   $Document = $Lexer->lex_file('My/Module.pm');
  26.  
  27. =head1 DESCRIPTION
  28.  
  29. The is the L<PPI> Lexer. In the larger scheme of things, its job is to take
  30. token streams, in a variety of forms, and "lex" them into nested structures.
  31.  
  32. Pretty much everything in this module happens behind the scenes at this
  33. point. In fact, at the moment you don't really need to instantiate the lexer
  34. at all, the three main methods will auto-instantiate themselves a
  35. C<PPI::Lexer> object as needed.
  36.  
  37. All methods do a one-shot "lex this and give me a L<PPI::Document> object".
  38.  
  39. In fact, if you are reading this, what you B<probably> want to do is to
  40. just "load a document", in which case you can do this in a much more
  41. direct and concise manner with one of the following.
  42.  
  43.   use PPI;
  44.   
  45.   $Document = PPI::Document->load( $filename );
  46.   $Document = PPI::Document->new( $string );
  47.  
  48. See L<PPI::Document> for more details.
  49.  
  50. For more unusual tasks, by all means forge onwards.
  51.  
  52. =head1 METHODS
  53.  
  54. =cut
  55.  
  56. use strict;
  57. use Scalar::Util    ();
  58. use Params::Util    qw{_STRING _INSTANCE};
  59. use List::MoreUtils ();
  60. use PPI             ();
  61. use PPI::Exception  ();
  62.  
  63. use vars qw{$VERSION $errstr *_PARENT %ROUND %RESOLVE};
  64. BEGIN {
  65.     $VERSION = '1.213';
  66.     $errstr  = '';
  67.  
  68.     # Faster than having another method call just
  69.     # to set the structure finish token.
  70.     *_PARENT = *PPI::Element::_PARENT;
  71.  
  72.     # Keyword -> Structure class maps
  73.     %ROUND = (
  74.         # Conditions
  75.         'if'     => 'PPI::Structure::Condition',
  76.         'elsif'  => 'PPI::Structure::Condition',
  77.         'unless' => 'PPI::Structure::Condition',
  78.         'while'  => 'PPI::Structure::Condition',
  79.         'until'  => 'PPI::Structure::Condition',
  80.  
  81.         # For(each)
  82.         'for'     => 'PPI::Structure::For',
  83.         'foreach' => 'PPI::Structure::For',
  84.     );
  85.  
  86.     # Opening brace to refining method
  87.     %RESOLVE = (
  88.         '(' => '_round',
  89.         '[' => '_square',
  90.         '{' => '_curly',
  91.     );
  92.  
  93. }
  94.  
  95. # Allows for experimental overriding of the tokenizer
  96. use vars qw{ $X_TOKENIZER };
  97. BEGIN {
  98.     $X_TOKENIZER ||= 'PPI::Tokenizer';
  99. }
  100. use constant X_TOKENIZER => $X_TOKENIZER;
  101.  
  102.  
  103.  
  104.  
  105.  
  106. #####################################################################
  107. # Constructor
  108.  
  109. =pod
  110.  
  111. =head2 new
  112.  
  113. The C<new> constructor creates a new C<PPI::Lexer> object. The object itself
  114. is merely used to hold various buffers and state data during the lexing
  115. process, and holds no significant data between -E<gt>lex_xxxxx calls.
  116.  
  117. Returns a new C<PPI::Lexer> object
  118.  
  119. =cut
  120.  
  121. sub new {
  122.     my $class = shift->_clear;
  123.     bless {
  124.         Tokenizer => undef, # Where we store the tokenizer for a run
  125.         buffer    => [],    # The input token buffer
  126.         delayed   => [],    # The "delayed insignificant tokens" buffer
  127.     }, $class;
  128. }
  129.  
  130.  
  131.  
  132.  
  133.  
  134. #####################################################################
  135. # Main Lexing Methods
  136.  
  137. =pod
  138.  
  139. =head2 lex_file $filename
  140.  
  141. The C<lex_file> method takes a filename as argument. It then loads the file,
  142. creates a L<PPI::Tokenizer> for the content and lexes the token stream
  143. produced by the tokenizer. Basically, a sort of all-in-one method for
  144. getting a L<PPI::Document> object from a file name.
  145.  
  146. Returns a L<PPI::Document> object, or C<undef> on error.
  147.  
  148. =cut
  149.  
  150. sub lex_file {
  151.     my $self = ref $_[0] ? shift : shift->new;
  152.     my $file = _STRING(shift);
  153.     unless ( defined $file ) {
  154.         return $self->_error("Did not pass a filename to PPI::Lexer::lex_file");
  155.     }
  156.  
  157.     # Create the Tokenizer
  158.     my $Tokenizer = eval {
  159.         X_TOKENIZER->new($file);
  160.     };
  161.     if ( _INSTANCE($@, 'PPI::Exception') ) {
  162.         return $self->_error( $@->message );
  163.     } elsif ( $@ ) {
  164.         return $self->_error( $errstr );
  165.     }
  166.  
  167.     $self->lex_tokenizer( $Tokenizer );
  168. }
  169.  
  170. =pod
  171.  
  172. =head2 lex_source $string
  173.  
  174. The C<lex_source> method takes a normal scalar string as argument. It
  175. creates a L<PPI::Tokenizer> object for the string, and then lexes the
  176. resulting token stream.
  177.  
  178. Returns a L<PPI::Document> object, or C<undef> on error.
  179.  
  180. =cut
  181.  
  182. sub lex_source {
  183.     my $self   = ref $_[0] ? shift : shift->new;
  184.     my $source = shift;
  185.     unless ( defined $source and not ref $source ) {
  186.         return $self->_error("Did not pass a string to PPI::Lexer::lex_source");
  187.     }
  188.  
  189.     # Create the Tokenizer and hand off to the next method
  190.     my $Tokenizer = eval {
  191.         X_TOKENIZER->new(\$source);
  192.     };
  193.     if ( _INSTANCE($@, 'PPI::Exception') ) {
  194.         return $self->_error( $@->message );
  195.     } elsif ( $@ ) {
  196.         return $self->_error( $errstr );
  197.     }
  198.  
  199.     $self->lex_tokenizer( $Tokenizer );
  200. }
  201.  
  202. =pod
  203.  
  204. =head2 lex_tokenizer $Tokenizer
  205.  
  206. The C<lex_tokenizer> takes as argument a L<PPI::Tokenizer> object. It
  207. lexes the token stream from the tokenizer into a L<PPI::Document> object.
  208.  
  209. Returns a L<PPI::Document> object, or C<undef> on error.
  210.  
  211. =cut
  212.  
  213. sub lex_tokenizer {
  214.     my $self      = ref $_[0] ? shift : shift->new;
  215.     my $Tokenizer = _INSTANCE(shift, 'PPI::Tokenizer');
  216.     return $self->_error(
  217.         "Did not pass a PPI::Tokenizer object to PPI::Lexer::lex_tokenizer"
  218.     ) unless $Tokenizer;
  219.  
  220.     # Create the empty document
  221.     my $Document = PPI::Document->new;
  222.  
  223.     # Lex the token stream into the document
  224.     $self->{Tokenizer} = $Tokenizer;
  225.     eval {
  226.         $self->_lex_document($Document);
  227.     };
  228.     if ( $@ ) {
  229.         # If an error occurs DESTROY the partially built document.
  230.         undef $Document;
  231.         if ( _INSTANCE($@, 'PPI::Exception') ) {
  232.             return $self->_error( $@->message );
  233.         } else {
  234.             return $self->_error( $errstr );
  235.         }
  236.     }
  237.  
  238.     return $Document;
  239. }
  240.  
  241.  
  242.  
  243.  
  244.  
  245. #####################################################################
  246. # Lex Methods - Document Object
  247.  
  248. =pod
  249.  
  250. =begin testing _lex_document 3
  251.  
  252. # Validate the creation of a null statement
  253. SCOPE: {
  254.     my $token = new_ok( 'PPI::Token::Structure' => [ ')'    ] );
  255.     my $brace = new_ok( 'PPI::Statement::UnmatchedBrace' => [ $token ] );
  256.     is( $brace->content, ')', '->content ok' );
  257. }
  258.  
  259. =end testing
  260.  
  261. =cut
  262.  
  263. sub _lex_document {
  264.     my ($self, $Document) = @_;
  265.     # my $self     = shift;
  266.     # my $Document = _INSTANCE(shift, 'PPI::Document') or return undef;
  267.  
  268.     # Start the processing loop
  269.     my $Token;
  270.     while ( ref($Token = $self->_get_token) ) {
  271.         # Add insignificant tokens directly beneath us
  272.         unless ( $Token->significant ) {
  273.             $self->_add_element( $Document, $Token );
  274.             next;
  275.         }
  276.  
  277.         if ( $Token->content eq ';' ) {
  278.             # It's a semi-colon on it's own.
  279.             # We call this a null statement.
  280.             $self->_add_element(
  281.                 $Document,
  282.                 PPI::Statement::Null->new($Token),
  283.             );
  284.             next;
  285.         }
  286.  
  287.         # Handle anything other than a structural element
  288.         unless ( ref $Token eq 'PPI::Token::Structure' ) {
  289.             # Determine the class for the Statement, and create it
  290.             my $Statement = $self->_statement($Document, $Token)->new($Token);
  291.  
  292.             # Move the lexing down into the statement
  293.             $self->_add_delayed( $Document );
  294.             $self->_add_element( $Document, $Statement );
  295.             $self->_lex_statement( $Statement );
  296.  
  297.             next;
  298.         }
  299.  
  300.         # Is this the opening of a structure?
  301.         if ( $Token->__LEXER__opens ) {
  302.             # This should actually have a Statement instead
  303.             $self->_rollback( $Token );
  304.             my $Statement = PPI::Statement->new;
  305.             $self->_add_element( $Document, $Statement );
  306.             $self->_lex_statement( $Statement );
  307.             next;
  308.         }
  309.  
  310.         # Is this the close of a structure.
  311.         if ( $Token->__LEXER__closes ) {
  312.             # Because we are at the top of the tree, this is an error.
  313.             # This means either a mis-parsing, or an mistake in the code.
  314.             # To handle this, we create a "Naked Close" statement
  315.             $self->_add_element( $Document,
  316.                 PPI::Statement::UnmatchedBrace->new($Token)
  317.             );
  318.             next;
  319.         }
  320.  
  321.         # Shouldn't be able to get here
  322.         PPI::Exception->throw('Lexer reached an illegal state');
  323.     }
  324.  
  325.     # Did we leave the main loop because of a Tokenizer error?
  326.     unless ( defined $Token ) {
  327.         my $errstr = $self->{Tokenizer} ? $self->{Tokenizer}->errstr : '';
  328.         $errstr ||= 'Unknown Tokenizer Error';
  329.         PPI::Exception->throw($errstr);
  330.     }
  331.  
  332.     # No error, it's just the end of file.
  333.     # Add any insignificant trailing tokens.
  334.     $self->_add_delayed( $Document );
  335.  
  336.     # If the Tokenizer has any v6 blocks to attach, do so now.
  337.     # Checking once at the end is faster than adding a special
  338.     # case check for every statement parsed.
  339.     my $perl6 = $self->{Tokenizer}->{'perl6'};
  340.     if ( @$perl6 ) {
  341.         my $includes = $Document->find( 'PPI::Statement::Include::Perl6' );
  342.         foreach my $include ( @$includes ) {
  343.             unless ( @$perl6 ) {
  344.                 PPI::Exception->throw('Failed to find a perl6 section');
  345.             }
  346.             $include->{perl6} = shift @$perl6;
  347.         }
  348.     }
  349.  
  350.     return 1;
  351. }
  352.  
  353.  
  354.  
  355.  
  356.  
  357. #####################################################################
  358. # Lex Methods - Statement Object
  359.  
  360. use vars qw{%STATEMENT_CLASSES};
  361. BEGIN {
  362.     # Keyword -> Statement Subclass
  363.     %STATEMENT_CLASSES = (
  364.         # Things that affect the timing of execution
  365.         'BEGIN'     => 'PPI::Statement::Scheduled',
  366.         'CHECK'     => 'PPI::Statement::Scheduled',
  367.         'UNITCHECK' => 'PPI::Statement::Scheduled',
  368.         'INIT'      => 'PPI::Statement::Scheduled',
  369.         'END'       => 'PPI::Statement::Scheduled',
  370.  
  371.         # Loading and context statement
  372.         'package'   => 'PPI::Statement::Package',
  373.         # 'use'       => 'PPI::Statement::Include',
  374.         'no'        => 'PPI::Statement::Include',
  375.         'require'   => 'PPI::Statement::Include',
  376.  
  377.         # Various declarations
  378.         'my'        => 'PPI::Statement::Variable',
  379.         'local'     => 'PPI::Statement::Variable',
  380.         'our'       => 'PPI::Statement::Variable',
  381.         'state'     => 'PPI::Statement::Variable',
  382.         # Statements starting with 'sub' could be any one of...
  383.         # 'sub'     => 'PPI::Statement::Sub',
  384.         # 'sub'     => 'PPI::Statement::Scheduled',
  385.         # 'sub'     => 'PPI::Statement',
  386.  
  387.         # Compound statement
  388.         'if'        => 'PPI::Statement::Compound',
  389.         'unless'    => 'PPI::Statement::Compound',
  390.         'for'       => 'PPI::Statement::Compound',
  391.         'foreach'   => 'PPI::Statement::Compound',
  392.         'while'     => 'PPI::Statement::Compound',
  393.         'until'     => 'PPI::Statement::Compound',
  394.  
  395.         # Switch statement
  396.         'given'     => 'PPI::Statement::Given',
  397.         'when'      => 'PPI::Statement::When',
  398.         'default'   => 'PPI::Statement::When',
  399.  
  400.         # Various ways of breaking out of scope
  401.         'redo'      => 'PPI::Statement::Break',
  402.         'next'      => 'PPI::Statement::Break',
  403.         'last'      => 'PPI::Statement::Break',
  404.         'return'    => 'PPI::Statement::Break',
  405.         'goto'      => 'PPI::Statement::Break',
  406.  
  407.         # Special sections of the file
  408.         '__DATA__'  => 'PPI::Statement::Data',
  409.         '__END__'   => 'PPI::Statement::End',
  410.     );
  411. }
  412.  
  413. sub _statement {
  414.     my ($self, $Parent, $Token) = @_;
  415.     # my $self   = shift;
  416.     # my $Parent = _INSTANCE(shift, 'PPI::Node')  or die "Bad param 1";
  417.     # my $Token  = _INSTANCE(shift, 'PPI::Token') or die "Bad param 2";
  418.  
  419.     # Check for things like ( parent => ... )
  420.     if (
  421.         $Parent->isa('PPI::Structure::List')
  422.         or
  423.         $Parent->isa('PPI::Structure::Constructor')
  424.     ) {
  425.         if ( $Token->isa('PPI::Token::Word') ) {
  426.             # Is the next significant token a =>
  427.             # Read ahead to the next significant token
  428.             my $Next;
  429.             while ( $Next = $self->_get_token ) {
  430.                 unless ( $Next->significant ) {
  431.                     push @{$self->{delayed}}, $Next;
  432.                     # $self->_delay_element( $Next );
  433.                     next;
  434.                 }
  435.  
  436.                 # Got the next token
  437.                 if (
  438.                     $Next->isa('PPI::Token::Operator')
  439.                     and
  440.                     $Next->content eq '=>'
  441.                 ) {
  442.                     # Is an ordinary expression
  443.                     $self->_rollback( $Next );
  444.                     return 'PPI::Statement::Expression';
  445.                 } else {
  446.                     last;
  447.                 }
  448.             }
  449.  
  450.             # Rollback and continue
  451.             $self->_rollback( $Next );
  452.         }
  453.     }
  454.  
  455.     # Is it a token in our known classes list
  456.     my $class = $STATEMENT_CLASSES{$Token->content};
  457.  
  458.     # Handle potential barewords for subscripts
  459.     if ( $Parent->isa('PPI::Structure::Subscript') ) {
  460.         # Fast obvious case, just an expression
  461.         unless ( $class and $class->isa('PPI::Statement::Expression') ) {
  462.             return 'PPI::Statement::Expression';
  463.         }
  464.  
  465.         # This is something like "my" or "our" etc... more subtle.
  466.         # Check if the next token is a closing curly brace.
  467.         # This means we are something like $h{my}
  468.         my $Next;
  469.         while ( $Next = $self->_get_token ) {
  470.             unless ( $Next->significant ) {
  471.                 push @{$self->{delayed}}, $Next;
  472.                 # $self->_delay_element( $Next );
  473.                 next;
  474.             }
  475.  
  476.             # Found the next significant token.
  477.             # Is it a closing curly brace?
  478.             if ( $Next->content eq '}' ) {
  479.                 $self->_rollback( $Next );
  480.                 return 'PPI::Statement::Expression';
  481.             } else {
  482.                 $self->_rollback( $Next );
  483.                 return $class;
  484.             }
  485.         }
  486.  
  487.         # End of file... this means it is something like $h{our
  488.         # which is probably going to be $h{our} ... I think
  489.         $self->_rollback( $Next );
  490.         return 'PPI::Statement::Expression';
  491.     }
  492.  
  493.     # If it's a token in our list, use that class
  494.     return $class if $class;
  495.  
  496.     # Handle the more in-depth sub detection
  497.     if ( $Token->content eq 'sub' ) {
  498.         # Read ahead to the next significant token
  499.         my $Next;
  500.         while ( $Next = $self->_get_token ) {
  501.             unless ( $Next->significant ) {
  502.                 push @{$self->{delayed}}, $Next;
  503.                 # $self->_delay_element( $Next );
  504.                 next;
  505.             }
  506.  
  507.             # Got the next significant token
  508.             my $sclass = $STATEMENT_CLASSES{$Next->content};
  509.             if ( $sclass and $sclass eq 'PPI::Statement::Scheduled' ) {
  510.                 $self->_rollback( $Next );
  511.                 return 'PPI::Statement::Scheduled';
  512.             }
  513.             if ( $Next->isa('PPI::Token::Word') ) {
  514.                 $self->_rollback( $Next );
  515.                 return 'PPI::Statement::Sub';
  516.             }
  517.  
  518.             ### Comment out these two, as they would return PPI::Statement anyway
  519.             # if ( $content eq '{' ) {
  520.             #    Anonymous sub at start of statement
  521.             #    return 'PPI::Statement';
  522.             # }
  523.             #
  524.             # if ( $Next->isa('PPI::Token::Prototype') ) {
  525.             #    Anonymous sub at start of statement
  526.             #    return 'PPI::Statement';
  527.             # }
  528.  
  529.             # PPI::Statement is the safest fall-through
  530.             $self->_rollback( $Next );
  531.             return 'PPI::Statement';
  532.         }
  533.  
  534.         # End of file... PPI::Statement::Sub is the most likely
  535.         $self->_rollback( $Next );
  536.         return 'PPI::Statement::Sub';
  537.     }
  538.  
  539.     if ( $Token->content eq 'use' ) {
  540.         # Add a special case for "use v6" lines.
  541.         my $Next;
  542.         while ( $Next = $self->_get_token ) {
  543.             unless ( $Next->significant ) {
  544.                 push @{$self->{delayed}}, $Next;
  545.                 # $self->_delay_element( $Next );
  546.                 next;
  547.             }
  548.  
  549.             # Found the next significant token.
  550.             # Is it a v6 use?
  551.             if ( $Next->content eq 'v6' ) {
  552.                 $self->_rollback( $Next );
  553.                 return 'PPI::Statement::Include::Perl6';
  554.             } else {
  555.                 $self->_rollback( $Next );
  556.                 return 'PPI::Statement::Include';
  557.             }
  558.         }
  559.  
  560.         # End of file... this means it is an incomplete use
  561.         # line, just treat it as a normal include.
  562.         $self->_rollback( $Next );
  563.         return 'PPI::Statement::Include';
  564.     }
  565.  
  566.     # If our parent is a Condition, we are an Expression
  567.     if ( $Parent->isa('PPI::Structure::Condition') ) {
  568.         return 'PPI::Statement::Expression';
  569.     }
  570.  
  571.     # If our parent is a List, we are also an expression
  572.     if ( $Parent->isa('PPI::Structure::List') ) {
  573.         return 'PPI::Statement::Expression';
  574.     }
  575.  
  576.     # Switch statements use expressions, as well.
  577.     if (
  578.         $Parent->isa('PPI::Structure::Given')
  579.         or
  580.         $Parent->isa('PPI::Structure::When')
  581.     ) {
  582.         return 'PPI::Statement::Expression';
  583.     }
  584.  
  585.     if ( _INSTANCE($Token, 'PPI::Token::Label') ) {
  586.         return 'PPI::Statement::Compound';
  587.     }
  588.  
  589.     # Beyond that, I have no idea for the moment.
  590.     # Just keep adding more conditions above this.
  591.     return 'PPI::Statement';
  592. }
  593.  
  594. sub _lex_statement {
  595.     my ($self, $Statement) = @_;
  596.     # my $self      = shift;
  597.     # my $Statement = _INSTANCE(shift, 'PPI::Statement') or die "Bad param 1";
  598.  
  599.     # Handle some special statements
  600.     if ( $Statement->isa('PPI::Statement::End') ) {
  601.         return $self->_lex_end( $Statement );
  602.     }
  603.  
  604.     # Begin processing tokens
  605.     my $Token;
  606.     while ( ref( $Token = $self->_get_token ) ) {
  607.         # Delay whitespace and comment tokens
  608.         unless ( $Token->significant ) {
  609.             push @{$self->{delayed}}, $Token;
  610.             # $self->_delay_element( $Token );
  611.             next;
  612.         }
  613.  
  614.         # Structual closes, and __DATA__ and __END__ tags implicitly
  615.         # end every type of statement
  616.         if (
  617.             $Token->__LEXER__closes
  618.             or
  619.             $Token->isa('PPI::Token::Separator')
  620.         ) {
  621.             # Rollback and end the statement
  622.             return $self->_rollback( $Token );
  623.         }
  624.  
  625.         # Normal statements never implicitly end
  626.         unless ( $Statement->__LEXER__normal ) {
  627.             # Have we hit an implicit end to the statement
  628.             unless ( $self->_continues( $Statement, $Token ) ) {
  629.                 # Rollback and finish the statement
  630.                 return $self->_rollback( $Token );
  631.             }
  632.         }
  633.  
  634.         # Any normal character just gets added
  635.         unless ( $Token->isa('PPI::Token::Structure') ) {
  636.             $self->_add_element( $Statement, $Token );
  637.             next;
  638.         }
  639.  
  640.         # Handle normal statement terminators
  641.         if ( $Token->content eq ';' ) {
  642.             $self->_add_element( $Statement, $Token );
  643.             return 1;
  644.         }
  645.  
  646.         # Which leaves us with a new structure
  647.  
  648.         # Determine the class for the structure and create it
  649.         my $method    = $RESOLVE{$Token->content};
  650.         my $Structure = $self->$method($Statement)->new($Token);
  651.  
  652.         # Move the lexing down into the Structure
  653.         $self->_add_delayed( $Statement );
  654.         $self->_add_element( $Statement, $Structure );
  655.         $self->_lex_structure( $Structure );
  656.     }
  657.  
  658.     # Was it an error in the tokenizer?
  659.     unless ( defined $Token ) {
  660.         PPI::Exception->throw;
  661.     }
  662.  
  663.     # No, it's just the end of the file...
  664.     # Roll back any insignificant tokens, they'll get added at the Document level
  665.     $self->_rollback;
  666. }
  667.  
  668. sub _lex_end {
  669.     my ($self, $Statement) = @_;
  670.     # my $self      = shift;
  671.     # my $Statement = _INSTANCE(shift, 'PPI::Statement::End') or die "Bad param 1";
  672.  
  673.     # End of the file, EVERYTHING is ours
  674.     my $Token;
  675.     while ( $Token = $self->_get_token ) {
  676.         # Inlined $Statement->__add_element($Token);
  677.         Scalar::Util::weaken(
  678.             $_PARENT{Scalar::Util::refaddr $Token} = $Statement
  679.         );
  680.         push @{$Statement->{children}}, $Token;
  681.     }
  682.  
  683.     # Was it an error in the tokenizer?
  684.     unless ( defined $Token ) {
  685.         PPI::Exception->throw;
  686.     }
  687.  
  688.     # No, it's just the end of the file...
  689.     # Roll back any insignificant tokens, they get added at the Document level
  690.     $self->_rollback;
  691. }
  692.  
  693. # For many statements, it can be dificult to determine the end-point.
  694. # This method takes a statement and the next significant token, and attempts
  695. # to determine if the there is a statement boundary between the two, or if
  696. # the statement can continue with the token.
  697. sub _continues {
  698.     my ($self, $Statement, $Token) = @_;
  699.     # my $self      = shift;
  700.     # my $Statement = _INSTANCE(shift, 'PPI::Statement') or die "Bad param 1";
  701.     # my $Token     = _INSTANCE(shift, 'PPI::Token')     or die "Bad param 2";
  702.  
  703.     # Handle the simple block case
  704.     # { print 1; }
  705.     if (
  706.         $Statement->schildren == 1
  707.         and
  708.         $Statement->schild(0)->isa('PPI::Structure::Block')
  709.     ) {
  710.         return '';
  711.     }
  712.  
  713.     # Alrighty then, there are only five implied end statement types,
  714.     # ::Scheduled blocks, ::Sub declarations, ::Compound, ::Given, and ::When
  715.     # statements.
  716.     unless ( ref($Statement) =~ /\b(?:Scheduled|Sub|Compound|Given|When)$/ ) {
  717.         return 1;
  718.     }
  719.  
  720.     # Of these five, ::Scheduled, ::Sub, ::Given, and ::When follow the same
  721.     # simple rule and can be handled first.
  722.     my @part      = $Statement->schildren;
  723.     my $LastChild = $part[-1];
  724.     unless ( $Statement->isa('PPI::Statement::Compound') ) {
  725.         # If the last significant element of the statement is a block,
  726.         # then a scheduled statement is done, no questions asked.
  727.         return ! $LastChild->isa('PPI::Structure::Block');
  728.     }
  729.  
  730.     # Now we get to compound statements, which kind of suck (to lex).
  731.     # However, of them all, the 'if' type, which includes unless, are
  732.     # relatively easy to handle compared to the others.
  733.     my $type = $Statement->type;
  734.     if ( $type eq 'if' ) {
  735.         # This should be one of the following
  736.         # if (EXPR) BLOCK
  737.         # if (EXPR) BLOCK else BLOCK
  738.         # if (EXPR) BLOCK elsif (EXPR) BLOCK ... else BLOCK
  739.  
  740.         # We only implicitly end on a block
  741.         unless ( $LastChild->isa('PPI::Structure::Block') ) {
  742.             # if (EXPR) ...
  743.             # if (EXPR) BLOCK else ...
  744.             # if (EXPR) BLOCK elsif (EXPR) BLOCK ...
  745.             return 1;
  746.         }
  747.  
  748.         # If the token before the block is an 'else',
  749.         # it's over, no matter what.
  750.         my $NextLast = $Statement->schild(-2);
  751.         if (
  752.             $NextLast
  753.             and
  754.             $NextLast->isa('PPI::Token')
  755.             and
  756.             $NextLast->isa('PPI::Token::Word')
  757.             and
  758.             $NextLast->content eq 'else'
  759.         ) {
  760.             return '';
  761.         }
  762.  
  763.         # Otherwise, we continue for 'elsif' or 'else' only.
  764.         if (
  765.             $Token->isa('PPI::Token::Word')
  766.             and (
  767.                 $Token->content eq 'else'
  768.                 or
  769.                 $Token->content eq 'elsif'
  770.             )
  771.         ) {
  772.             return 1;
  773.         }
  774.  
  775.         return '';
  776.     }
  777.  
  778.     if ( $type eq 'label' ) {
  779.         # We only have the label so far, could be any of
  780.         # LABEL while (EXPR) BLOCK
  781.         # LABEL while (EXPR) BLOCK continue BLOCK
  782.         # LABEL for (EXPR; EXPR; EXPR) BLOCK
  783.         # LABEL foreach VAR (LIST) BLOCK
  784.         # LABEL foreach VAR (LIST) BLOCK continue BLOCK
  785.         # LABEL BLOCK continue BLOCK
  786.  
  787.         # Handle cases with a word after the label
  788.         if (
  789.             $Token->isa('PPI::Token::Word')
  790.             and
  791.             $Token->content =~ /^(?:while|until|for|foreach)$/
  792.         ) {
  793.             return 1;
  794.         }
  795.  
  796.         # Handle labelled blocks
  797.         if ( $Token->isa('PPI::Token::Structure') && $Token->content eq '{' ) {
  798.             return 1;
  799.         }
  800.  
  801.         return '';
  802.     }
  803.  
  804.     # Handle the common "after round braces" case
  805.     if ( $LastChild->isa('PPI::Structure') and $LastChild->braces eq '()' ) {
  806.         # LABEL while (EXPR) ...
  807.         # LABEL while (EXPR) ...
  808.         # LABEL for (EXPR; EXPR; EXPR) ...
  809.         # LABEL for VAR (LIST) ...
  810.         # LABEL foreach VAR (LIST) ...
  811.         # Only a block will do
  812.         return $Token->isa('PPI::Token::Structure') && $Token->content eq '{';
  813.     }
  814.  
  815.     if ( $type eq 'for' ) {
  816.         # LABEL for (EXPR; EXPR; EXPR) BLOCK
  817.         if (
  818.             $LastChild->isa('PPI::Token::Word')
  819.             and
  820.             $LastChild->content =~ /^for(?:each)?\z/
  821.         ) {
  822.             # LABEL for ...
  823.             if (
  824.                 (
  825.                     $Token->isa('PPI::Token::Structure')
  826.                     and
  827.                     $Token->content eq '('
  828.                 )
  829.                 or
  830.                 $Token->isa('PPI::Token::QuoteLike::Words')
  831.             ) {
  832.                 return 1;
  833.             }
  834.  
  835.             if ( $LastChild->isa('PPI::Token::QuoteLike::Words') ) {
  836.                 # LABEL for VAR QW{} ...
  837.                 # LABEL foreach VAR QW{} ...
  838.                 # Only a block will do
  839.                 return $Token->isa('PPI::Token::Structure') && $Token->content eq '{';
  840.             }
  841.  
  842.             # In this case, we can also behave like a foreach
  843.             $type = 'foreach';
  844.  
  845.         } elsif ( $LastChild->isa('PPI::Structure::Block') ) {
  846.             # LABEL for (EXPR; EXPR; EXPR) BLOCK
  847.             # That's it, nothing can continue
  848.             return '';
  849.  
  850.         } elsif ( $LastChild->isa('PPI::Token::QuoteLike::Words') ) {
  851.             # LABEL for VAR QW{} ...
  852.             # LABEL foreach VAR QW{} ...
  853.             # Only a block will do
  854.             return $Token->isa('PPI::Token::Structure') && $Token->content eq '{';
  855.         }
  856.     }
  857.  
  858.     # Handle the common continue case
  859.     if ( $LastChild->isa('PPI::Token::Word') and $LastChild->content eq 'continue' ) {
  860.         # LABEL while (EXPR) BLOCK continue ...
  861.         # LABEL foreach VAR (LIST) BLOCK continue ...
  862.         # LABEL BLOCK continue ...
  863.         # Only a block will do
  864.         return $Token->isa('PPI::Token::Structure') && $Token->content eq '{';
  865.     }
  866.  
  867.     # Handle the common continuable block case
  868.     if ( $LastChild->isa('PPI::Structure::Block') ) {
  869.         # LABEL while (EXPR) BLOCK
  870.         # LABEL while (EXPR) BLOCK ...
  871.         # LABEL for (EXPR; EXPR; EXPR) BLOCK
  872.         # LABEL foreach VAR (LIST) BLOCK
  873.         # LABEL foreach VAR (LIST) BLOCK ...
  874.         # LABEL BLOCK ...
  875.         # Is this the block for a continue?
  876.         if ( _INSTANCE($part[-2], 'PPI::Token::Word') and $part[-2]->content eq 'continue' ) {
  877.             # LABEL while (EXPR) BLOCK continue BLOCK
  878.             # LABEL foreach VAR (LIST) BLOCK continue BLOCK
  879.             # LABEL BLOCK continue BLOCK
  880.             # That's it, nothing can continue this
  881.             return '';
  882.         }
  883.  
  884.         # Only a continue will do
  885.         return $Token->isa('PPI::Token::Word') && $Token->content eq 'continue';
  886.     }
  887.  
  888.     if ( $type eq 'block' ) {
  889.         # LABEL BLOCK continue BLOCK
  890.         # Every possible case is covered in the common cases above
  891.     }
  892.  
  893.     if ( $type eq 'while' ) {
  894.         # LABEL while (EXPR) BLOCK
  895.         # LABEL while (EXPR) BLOCK continue BLOCK
  896.         # LABEL until (EXPR) BLOCK
  897.         # LABEL until (EXPR) BLOCK continue BLOCK
  898.         # The only case not covered is the while ...
  899.         if (
  900.             $LastChild->isa('PPI::Token::Word')
  901.             and (
  902.                 $LastChild->content eq 'while'
  903.                 or
  904.                 $LastChild->content eq 'until'
  905.             )
  906.         ) {
  907.             # LABEL while ...
  908.             # LABEL until ...
  909.             # Only a condition structure will do
  910.             return $Token->isa('PPI::Token::Structure') && $Token->content eq '(';
  911.         }
  912.     }
  913.  
  914.     if ( $type eq 'foreach' ) {
  915.         # LABEL foreach VAR (LIST) BLOCK
  916.         # LABEL foreach VAR (LIST) BLOCK continue BLOCK
  917.         # The only two cases that have not been covered already are
  918.         # 'foreach ...' and 'foreach VAR ...'
  919.  
  920.         if ( $LastChild->isa('PPI::Token::Symbol') ) {
  921.             # LABEL foreach my $scalar ...
  922.             # Open round brace, or a quotewords
  923.             return 1 if $Token->isa('PPI::Token::Structure') && $Token->content eq '(';
  924.             return 1 if $Token->isa('PPI::Token::QuoteLike::Words');
  925.             return '';
  926.         }
  927.  
  928.         if ( $LastChild->content eq 'foreach' or $LastChild->content eq 'for' ) {
  929.             # There are three possibilities here
  930.             if (
  931.                 $Token->isa('PPI::Token::Word')
  932.                 and (
  933.                     ($STATEMENT_CLASSES{ $Token->content } || '')
  934.                     eq
  935.                     'PPI::Statement::Variable'
  936.                 )
  937.             ) {
  938.                 # VAR == 'my ...'
  939.                 return 1;
  940.             } elsif ( $Token->content =~ /^\$/ ) {
  941.                 # VAR == '$scalar'
  942.                 return 1;
  943.             } elsif ( $Token->isa('PPI::Token::Structure') and $Token->content eq '(' ) {
  944.                 return 1;
  945.             } elsif ( $Token->isa('PPI::Token::QuoteLike::Words') ) {
  946.                 return 1;
  947.             } else {
  948.                 return '';
  949.             }
  950.         }
  951.  
  952.         if (
  953.             ($STATEMENT_CLASSES{ $LastChild->content } || '')
  954.             eq
  955.             'PPI::Statement::Variable'
  956.         ) {
  957.             # LABEL foreach my ...
  958.             # Only a scalar will do
  959.             return $Token->content =~ /^\$/;
  960.         }
  961.  
  962.         # Handle the rare for my $foo qw{bar} ... case
  963.         if ( $LastChild->isa('PPI::Token::QuoteLike::Words') ) {
  964.             # LABEL for VAR QW ...
  965.             # LABEL foreach VAR QW ...
  966.             # Only a block will do
  967.             return $Token->isa('PPI::Token::Structure') && $Token->content eq '{';
  968.         }
  969.     }
  970.  
  971.     # Something we don't know about... what could it be
  972.     PPI::Exception->throw("Illegal state in '$type' compound statement");
  973. }
  974.  
  975.  
  976.  
  977.  
  978.  
  979. #####################################################################
  980. # Lex Methods - Structure Object
  981.  
  982. # Given a parent element, and a ( token to open a structure, determine
  983. # the class that the structure should be.
  984. sub _round {
  985.     my ($self, $Parent) = @_;
  986.     # my $self   = shift;
  987.     # my $Parent = _INSTANCE(shift, 'PPI::Node') or die "Bad param 1";
  988.  
  989.     # Get the last significant element in the parent
  990.     my $Element = $Parent->schild(-1);
  991.     if ( _INSTANCE($Element, 'PPI::Token::Word') ) {
  992.         # Can it be determined because it is a keyword?
  993.         my $rclass = $ROUND{$Element->content};
  994.         return $rclass if $rclass;
  995.     }
  996.  
  997.     # If we are part of a for or foreach statement, we are a ForLoop
  998.     if ( $Parent->isa('PPI::Statement::Compound') ) {
  999.         if ( $Parent->type =~ /^for(?:each)?$/ ) {
  1000.             return 'PPI::Structure::For';
  1001.         }
  1002.     } elsif ( $Parent->isa('PPI::Statement::Given') ) {
  1003.         return 'PPI::Structure::Given';
  1004.     } elsif ( $Parent->isa('PPI::Statement::When') ) {
  1005.         return 'PPI::Structure::When';
  1006.     }
  1007.  
  1008.     # Otherwise, it must be a list
  1009.  
  1010.     # If the previous element is -> then we mark it as a dereference
  1011.     if ( _INSTANCE($Element, 'PPI::Token::Operator') and $Element->content eq '->' ) {
  1012.         $Element->{_dereference} = 1;
  1013.     }
  1014.  
  1015.     'PPI::Structure::List'
  1016. }
  1017.  
  1018. # Given a parent element, and a [ token to open a structure, determine
  1019. # the class that the structure should be.
  1020. sub _square {
  1021.     my ($self, $Parent) = @_;
  1022.     # my $self   = shift;
  1023.     # my $Parent = _INSTANCE(shift, 'PPI::Node') or die "Bad param 1";
  1024.  
  1025.     # Get the last significant element in the parent
  1026.     my $Element = $Parent->schild(-1);
  1027.  
  1028.     # Is this a subscript, like $foo[1] or $foo{expr}
  1029.     
  1030.     if ( $Element ) {
  1031.         if ( $Element->isa('PPI::Token::Operator') and $Element->content eq '->' ) {
  1032.             # $foo->[]
  1033.             $Element->{_dereference} = 1;
  1034.             return 'PPI::Structure::Subscript';
  1035.         }
  1036.         if ( $Element->isa('PPI::Structure::Subscript') ) {
  1037.             # $foo{}[]
  1038.             return 'PPI::Structure::Subscript';
  1039.         }
  1040.         if ( $Element->isa('PPI::Token::Symbol') and $Element->content =~ /^(?:\$|\@)/ ) {
  1041.             # $foo[], @foo[]
  1042.             return 'PPI::Structure::Subscript';
  1043.         }
  1044.         # FIXME - More cases to catch
  1045.     }
  1046.  
  1047.     # Otherwise, we assume that it's an anonymous arrayref constructor
  1048.     'PPI::Structure::Constructor';
  1049. }
  1050.  
  1051. use vars qw{%CURLY_CLASSES @CURLY_LOOKAHEAD_CLASSES};
  1052. BEGIN {
  1053.     # Keyword -> Structure class maps
  1054.     %CURLY_CLASSES = (
  1055.         # Blocks
  1056.         'sub'  => 'PPI::Structure::Block',
  1057.         'grep' => 'PPI::Structure::Block',
  1058.         'map'  => 'PPI::Structure::Block',
  1059.         'sort' => 'PPI::Structure::Block',
  1060.         'do'   => 'PPI::Structure::Block',
  1061.  
  1062.         # Hash constructors
  1063.         'scalar' => 'PPI::Structure::Constructor',
  1064.         '='      => 'PPI::Structure::Constructor',
  1065.         '||='    => 'PPI::Structure::Constructor',
  1066.         ','      => 'PPI::Structure::Constructor',
  1067.         '=>'     => 'PPI::Structure::Constructor',
  1068.         '+'      => 'PPI::Structure::Constructor', # per perlref
  1069.     );
  1070.  
  1071.     @CURLY_LOOKAHEAD_CLASSES = (
  1072.         {},    # not used
  1073.         {
  1074.         ';'    => 'PPI::Structure::Block', # per perlref
  1075.         '}'    => 'PPI::Structure::Constructor',
  1076.         },
  1077.         {
  1078.         '=>'   => 'PPI::Structure::Constructor',
  1079.         },
  1080.     );
  1081. }
  1082.  
  1083. =pod
  1084.  
  1085. =begin testing _curly 24
  1086.  
  1087. my $document = PPI::Document->new(\<<'END_PERL');
  1088. use constant { One => 1 };
  1089. use constant 1 { One => 1 };
  1090. $foo->{bar};
  1091. $foo[1]{bar};
  1092. $foo{bar};
  1093. sub {1};
  1094. grep { $_ } 0 .. 2;
  1095. map { $_ => 1 } 0 .. 2;
  1096. sort { $b <=> $a } 0 .. 2;
  1097. do {foo};
  1098. $foo = { One => 1 };
  1099. $foo ||= { One => 1 };
  1100. 1, { One => 1 };
  1101. One => { Two => 2 };
  1102. {foo, bar};
  1103. {foo => bar};
  1104. {};
  1105. +{foo, bar};
  1106. {; => bar};
  1107. @foo{'bar', 'baz'};
  1108. @{$foo}{'bar', 'baz'};
  1109. ${$foo}{bar};
  1110. END_PERL
  1111.  
  1112. isa_ok( $document, 'PPI::Document' );
  1113. $document->index_locations();
  1114.  
  1115. my @statements;
  1116. foreach my $elem ( @{ $document->find( 'PPI::Statement' ) || [] } ) {
  1117.     $statements[ $elem->line_number() - 1 ] ||= $elem;
  1118. }
  1119.  
  1120. is( scalar(@statements), 22, 'Found 22 statements' );
  1121.  
  1122. isa_ok( $statements[0]->schild(2), 'PPI::Structure::Constructor',
  1123.     'The curly in ' . $statements[0]);
  1124. isa_ok( $statements[1]->schild(3), 'PPI::Structure::Constructor',
  1125.     'The curly in ' . $statements[1]);
  1126. isa_ok( $statements[2]->schild(2), 'PPI::Structure::Subscript',
  1127.     'The curly in ' . $statements[2]);
  1128. isa_ok( $statements[3]->schild(2), 'PPI::Structure::Subscript',
  1129.     'The curly in ' . $statements[3]);
  1130. isa_ok( $statements[4]->schild(1), 'PPI::Structure::Subscript',
  1131.     'The curly in ' . $statements[4]);
  1132. isa_ok( $statements[5]->schild(1), 'PPI::Structure::Block',
  1133.     'The curly in ' . $statements[5]);
  1134. isa_ok( $statements[6]->schild(1), 'PPI::Structure::Block',
  1135.     'The curly in ' . $statements[6]);
  1136. isa_ok( $statements[7]->schild(1), 'PPI::Structure::Block',
  1137.     'The curly in ' . $statements[7]);
  1138. isa_ok( $statements[8]->schild(1), 'PPI::Structure::Block',
  1139.     'The curly in ' . $statements[8]);
  1140. isa_ok( $statements[9]->schild(1), 'PPI::Structure::Block',
  1141.     'The curly in ' . $statements[9]);
  1142. isa_ok( $statements[10]->schild(2), 'PPI::Structure::Constructor',
  1143.     'The curly in ' . $statements[10]);
  1144. isa_ok( $statements[11]->schild(3), 'PPI::Structure::Constructor',
  1145.     'The curly in ' . $statements[11]);
  1146. isa_ok( $statements[12]->schild(2), 'PPI::Structure::Constructor',
  1147.     'The curly in ' . $statements[12]);
  1148. isa_ok( $statements[13]->schild(2), 'PPI::Structure::Constructor',
  1149.     'The curly in ' . $statements[13]);
  1150. isa_ok( $statements[14]->schild(0), 'PPI::Structure::Block',
  1151.     'The curly in ' . $statements[14]);
  1152. isa_ok( $statements[15]->schild(0), 'PPI::Structure::Constructor',
  1153.     'The curly in ' . $statements[15]);
  1154. isa_ok( $statements[16]->schild(0), 'PPI::Structure::Constructor',
  1155.     'The curly in ' . $statements[16]);
  1156. isa_ok( $statements[17]->schild(1), 'PPI::Structure::Constructor',
  1157.     'The curly in ' . $statements[17]);
  1158. isa_ok( $statements[18]->schild(0), 'PPI::Structure::Block',
  1159.     'The curly in ' . $statements[18]);
  1160. isa_ok( $statements[19]->schild(1), 'PPI::Structure::Subscript',
  1161.     'The curly in ' . $statements[19]);
  1162. isa_ok( $statements[20]->schild(2), 'PPI::Structure::Subscript',
  1163.     'The curly in ' . $statements[20]);
  1164. isa_ok( $statements[21]->schild(2), 'PPI::Structure::Subscript',
  1165.     'The curly in ' . $statements[21]);
  1166.  
  1167. =end testing
  1168.  
  1169. =cut
  1170.  
  1171. # Given a parent element, and a { token to open a structure, determine
  1172. # the class that the structure should be.
  1173. sub _curly {
  1174.     my ($self, $Parent) = @_;
  1175.     # my $self   = shift;
  1176.     # my $Parent = _INSTANCE(shift, 'PPI::Node') or die "Bad param 1";
  1177.  
  1178.     # Get the last significant element in the parent
  1179.     my $Element = $Parent->schild(-1);
  1180.     my $content = $Element ? $Element->content : '';
  1181.  
  1182.     # Is this a subscript, like $foo[1] or $foo{expr}
  1183.     if ( $Element ) {
  1184.         if ( $content eq '->' and $Element->isa('PPI::Token::Operator') ) {
  1185.             # $foo->{}
  1186.             $Element->{_dereference} = 1;
  1187.             return 'PPI::Structure::Subscript';
  1188.         }
  1189.         if ( $Element->isa('PPI::Structure::Subscript') ) {
  1190.             # $foo[]{}
  1191.             return 'PPI::Structure::Subscript';
  1192.         }
  1193.         if ( $content =~ /^(?:\$|\@)/ and $Element->isa('PPI::Token::Symbol') ) {
  1194.             # $foo{}, @foo{}
  1195.             return 'PPI::Structure::Subscript';
  1196.         }
  1197.         if ( $Element->isa('PPI::Structure::Block') ) {
  1198.             # deference - ${$hash_ref}{foo}
  1199.             #     or even ${burfle}{foo}
  1200.             # hash slice - @{$hash_ref}{'foo', 'bar'}
  1201.             if ( my $prior = $Parent->schild(-2) ) {
  1202.                 my $prior_content = $prior->content();
  1203.                 $prior->isa( 'PPI::Token::Cast' )
  1204.                     and ( $prior_content eq '@' ||
  1205.                         $prior_content eq '$' )
  1206.                     and return 'PPI::Structure::Subscript';
  1207.             }
  1208.         }
  1209.         if ( $CURLY_CLASSES{$content} ) {
  1210.             # Known type
  1211.             return $CURLY_CLASSES{$content};
  1212.         }
  1213.     }
  1214.  
  1215.     # Are we in a compound statement
  1216.     if ( $Parent->isa('PPI::Statement::Compound') ) {
  1217.         # We will only encounter blocks in compound statements
  1218.         return 'PPI::Structure::Block';
  1219.     }
  1220.  
  1221.     # Are we the second or third argument of use
  1222.     if ( $Parent->isa('PPI::Statement::Include') ) {
  1223.         if ( $Parent->schildren == 2 ||
  1224.             $Parent->schildren == 3 &&
  1225.             $Parent->schild(2)->isa('PPI::Token::Number')
  1226.         ) {
  1227.             # This is something like use constant { ... };
  1228.             return 'PPI::Structure::Constructor';
  1229.         }
  1230.     }
  1231.  
  1232.     # Unless we are at the start of the statement, everything else should be a block
  1233.     ### FIXME This is possibly a bad choice, but will have to do for now.
  1234.     return 'PPI::Structure::Block' if $Element;
  1235.  
  1236.     # Special case: Are we the param of a core function
  1237.     # i.e. map({ $_ => 1 } @foo)
  1238.     if (
  1239.         $Parent->isa('PPI::Statement')
  1240.         and
  1241.         _INSTANCE($Parent->parent, 'PPI::Structure::List')
  1242.     ) {
  1243.         my $function = $Parent->parent->parent->schild(-2);
  1244.         if ( $function and $function->content =~ /^(?:map|grep|sort)$/ ) {
  1245.             return 'PPI::Structure::Block';
  1246.         }
  1247.     }
  1248.  
  1249.     # We need to scan ahead.
  1250.     my $Next;
  1251.     my $position = 0;
  1252.     my @delayed  = ();
  1253.     while ( $Next = $self->_get_token ) {
  1254.         unless ( $Next->significant ) {
  1255.             push @delayed, $Next;
  1256.             next;
  1257.         }
  1258.  
  1259.         # If we are off the end of the lookahead array,
  1260.         if ( ++$position >= @CURLY_LOOKAHEAD_CLASSES ) {
  1261.             # default to block.
  1262.             $self->_buffer( splice(@delayed), $Next );
  1263.             last;
  1264.         # If the content at this position is known
  1265.         } elsif ( my $class = $CURLY_LOOKAHEAD_CLASSES[$position]
  1266.             {$Next->content} ) {
  1267.             # return the associated class.
  1268.             $self->_buffer( splice(@delayed), $Next );
  1269.             return $class;
  1270.         }
  1271.  
  1272.         # Delay and continue
  1273.         push @delayed, $Next;
  1274.     }
  1275.  
  1276.     # Hit the end of the document, or bailed out, go with block
  1277.     $self->_buffer( splice(@delayed) );
  1278.     if ( ref $Parent eq 'PPI::Statement' ) {
  1279.         bless $Parent, 'PPI::Statement::Compound';
  1280.     }
  1281.     return 'PPI::Structure::Block';
  1282. }
  1283.  
  1284. =pod
  1285.  
  1286. =begin testing _lex_structure 4
  1287.  
  1288. # Validate the creation of a null statement
  1289. SCOPE: {
  1290.     my $token = new_ok( 'PPI::Token::Structure' => [ ';'    ] );
  1291.     my $null  = new_ok( 'PPI::Statement::Null'  => [ $token ] );
  1292.     is( $null->content, ';', '->content ok' );
  1293. }
  1294.  
  1295. # Validate the creation of an empty statement
  1296. new_ok( 'PPI::Statement' => [ ] );
  1297.  
  1298. =end testing
  1299.  
  1300. =cut
  1301.  
  1302. sub _lex_structure {
  1303.     my ($self, $Structure) = @_;
  1304.     # my $self      = shift;
  1305.     # my $Structure = _INSTANCE(shift, 'PPI::Structure') or die "Bad param 1";
  1306.  
  1307.     # Start the processing loop
  1308.     my $Token;
  1309.     while ( ref($Token = $self->_get_token) ) {
  1310.         # Is this a direct type token
  1311.         unless ( $Token->significant ) {
  1312.             push @{$self->{delayed}}, $Token;
  1313.             # $self->_delay_element( $Token );
  1314.             next;
  1315.         }
  1316.  
  1317.         # Anything other than a Structure starts a Statement
  1318.         unless ( $Token->isa('PPI::Token::Structure') ) {
  1319.             # Because _statement may well delay and rollback itself,
  1320.             # we need to add the delayed tokens early
  1321.             $self->_add_delayed( $Structure );
  1322.  
  1323.             # Determine the class for the Statement and create it
  1324.             my $Statement = $self->_statement($Structure, $Token)->new($Token);
  1325.  
  1326.             # Move the lexing down into the Statement
  1327.             $self->_add_element( $Structure, $Statement );
  1328.             $self->_lex_statement( $Statement );
  1329.  
  1330.             next;
  1331.         }
  1332.  
  1333.         # Is this the opening of another structure directly inside us?
  1334.         if ( $Token->__LEXER__opens ) {
  1335.             # Rollback the Token, and recurse into the statement
  1336.             $self->_rollback( $Token );
  1337.             my $Statement = PPI::Statement->new;
  1338.             $self->_add_element( $Structure, $Statement );
  1339.             $self->_lex_statement( $Statement );
  1340.             next;
  1341.         }
  1342.  
  1343.         # Is this the close of a structure ( which would be an error )
  1344.         if ( $Token->__LEXER__closes ) {
  1345.             # Is this OUR closing structure
  1346.             if ( $Token->content eq $Structure->start->__LEXER__opposite ) {
  1347.                 # Add any delayed tokens, and the finishing token (the ugly way)
  1348.                 $self->_add_delayed( $Structure );
  1349.                 $Structure->{finish} = $Token;
  1350.                 Scalar::Util::weaken(
  1351.                     $_PARENT{Scalar::Util::refaddr $Token} = $Structure
  1352.                 );
  1353.  
  1354.                 # Confirm that ForLoop structures are actually so, and
  1355.                 # aren't really a list.
  1356.                 if ( $Structure->isa('PPI::Structure::For') ) {
  1357.                     if ( 2 > scalar grep {
  1358.                         $_->isa('PPI::Statement')
  1359.                     } $Structure->children ) {
  1360.                         bless($Structure, 'PPI::Structure::List');
  1361.                     }
  1362.                 }
  1363.                 return 1;
  1364.             }
  1365.  
  1366.             # Unmatched closing brace.
  1367.             # Either they typed the wrong thing, or haven't put
  1368.             # one at all. Either way it's an error we need to
  1369.             # somehow handle gracefully. For now, we'll treat it
  1370.             # as implicitly ending the structure. This causes the
  1371.             # least damage across the various reasons why this
  1372.             # might have happened.
  1373.             return $self->_rollback( $Token );
  1374.         }
  1375.  
  1376.         # It's a semi-colon on it's own, just inside the block.
  1377.         # This is a null statement.
  1378.         $self->_add_element(
  1379.             $Structure,
  1380.             PPI::Statement::Null->new($Token),
  1381.         );
  1382.     }
  1383.  
  1384.     # Is this an error
  1385.     unless ( defined $Token ) {
  1386.         PPI::Exception->throw;
  1387.     }
  1388.  
  1389.     # No, it's just the end of file.
  1390.     # Add any insignificant trailing tokens.
  1391.     $self->_add_delayed( $Structure );
  1392. }
  1393.  
  1394.  
  1395.  
  1396.  
  1397.  
  1398. #####################################################################
  1399. # Support Methods
  1400.  
  1401. # Get the next token for processing, handling buffering
  1402. sub _get_token {
  1403.     shift(@{$_[0]->{buffer}}) or $_[0]->{Tokenizer}->get_token;
  1404. }
  1405.  
  1406. # Old long version of the above
  1407. # my $self = shift;
  1408. #     # First from the buffer
  1409. #     if ( @{$self->{buffer}} ) {
  1410. #         return shift @{$self->{buffer}};
  1411. #     }
  1412. #
  1413. #     # Then from the Tokenizer
  1414. #     $self->{Tokenizer}->get_token;
  1415. # }
  1416.  
  1417. # Delay the addition of a insignificant elements.
  1418. # This ended up being inlined.
  1419. # sub _delay_element {
  1420. #     my $self    = shift;
  1421. #     my $Element = _INSTANCE(shift, 'PPI::Element') or die "Bad param 1";
  1422. #     push @{ $_[0]->{delayed} }, $_[1];
  1423. # }
  1424.  
  1425. # Add an Element to a Node, including any delayed Elements
  1426. sub _add_element {
  1427.     my ($self, $Parent, $Element) = @_;
  1428.     # my $self    = shift;
  1429.     # my $Parent  = _INSTANCE(shift, 'PPI::Node')    or die "Bad param 1";
  1430.     # my $Element = _INSTANCE(shift, 'PPI::Element') or die "Bad param 2";
  1431.  
  1432.     # Handle a special case, where a statement is not fully resolved
  1433.     if ( ref $Parent eq 'PPI::Statement' ) {
  1434.         my $first  = $Parent->schild(0);
  1435.         my $second = $Parent->schild(1);
  1436.         if ( $first and $first->isa('PPI::Token::Label') and ! $second ) {
  1437.             # It's a labelled statement
  1438.             if ( $STATEMENT_CLASSES{$second->content} ) {
  1439.                 bless $Parent, $STATEMENT_CLASSES{$second->content};
  1440.             }
  1441.         }
  1442.     }
  1443.  
  1444.     # Add first the delayed, from the front, then the passed element
  1445.     foreach my $el ( @{$self->{delayed}} ) {
  1446.         Scalar::Util::weaken(
  1447.             $_PARENT{Scalar::Util::refaddr $el} = $Parent
  1448.         );
  1449.         # Inlined $Parent->__add_element($el);
  1450.     }
  1451.     Scalar::Util::weaken(
  1452.         $_PARENT{Scalar::Util::refaddr $Element} = $Parent
  1453.     );
  1454.     push @{$Parent->{children}}, @{$self->{delayed}}, $Element;
  1455.  
  1456.     # Clear the delayed elements
  1457.     $self->{delayed} = [];
  1458. }
  1459.  
  1460. # Specifically just add any delayed tokens, if any.
  1461. sub _add_delayed {
  1462.     my ($self, $Parent) = @_;
  1463.     # my $self   = shift;
  1464.     # my $Parent = _INSTANCE(shift, 'PPI::Node') or die "Bad param 1";
  1465.  
  1466.     # Add any delayed
  1467.     foreach my $el ( @{$self->{delayed}} ) {
  1468.         Scalar::Util::weaken(
  1469.             $_PARENT{Scalar::Util::refaddr $el} = $Parent
  1470.         );
  1471.         # Inlined $Parent->__add_element($el);
  1472.     }
  1473.     push @{$Parent->{children}}, @{$self->{delayed}};
  1474.  
  1475.     # Clear the delayed elements
  1476.     $self->{delayed} = [];
  1477. }
  1478.  
  1479. # Rollback the delayed tokens, plus any passed. Once all the tokens
  1480. # have been moved back on to the buffer, the order should be.
  1481. # <--- @{$self->{delayed}}, @_, @{$self->{buffer}} <----
  1482. sub _rollback {
  1483.     my $self = shift;
  1484.  
  1485.     # First, put any passed objects back
  1486.     if ( @_ ) {
  1487.         unshift @{$self->{buffer}}, splice @_;
  1488.     }
  1489.  
  1490.     # Then, put back anything delayed
  1491.     if ( @{$self->{delayed}} ) {
  1492.         unshift @{$self->{buffer}}, splice @{$self->{delayed}};
  1493.     }
  1494.  
  1495.     1;
  1496. }
  1497.  
  1498. # Partial rollback, just return a single list to the buffer
  1499. sub _buffer {
  1500.     my $self = shift;
  1501.  
  1502.     # Put any passed objects back
  1503.     if ( @_ ) {
  1504.         unshift @{$self->{buffer}}, splice @_;
  1505.     }
  1506.  
  1507.     1;
  1508. }
  1509.  
  1510.  
  1511.  
  1512.  
  1513.  
  1514. #####################################################################
  1515. # Error Handling
  1516.  
  1517. # Set the error message
  1518. sub _error {
  1519.     $errstr = $_[1];
  1520.     undef;
  1521. }
  1522.  
  1523. # Clear the error message.
  1524. # Returns the object as a convenience.
  1525. sub _clear {
  1526.     $errstr = '';
  1527.     $_[0];
  1528. }
  1529.  
  1530. =pod
  1531.  
  1532. =head2 errstr
  1533.  
  1534. For any error that occurs, you can use the C<errstr>, as either
  1535. a static or object method, to access the error message.
  1536.  
  1537. If no error occurs for any particular action, C<errstr> will return false.
  1538.  
  1539. =cut
  1540.  
  1541. sub errstr {
  1542.     $errstr;
  1543. }
  1544.  
  1545.  
  1546.  
  1547.  
  1548.  
  1549. #####################################################################
  1550. # PDOM Extensions
  1551. #
  1552. # This is something of a future expansion... ignore it for now :)
  1553. #
  1554. # use PPI::Statement::Sub ();
  1555. #
  1556. # sub PPI::Statement::Sub::__LEXER__normal { '' }
  1557.  
  1558. 1;
  1559.  
  1560. =pod
  1561.  
  1562. =head1 TO DO
  1563.  
  1564. - Add optional support for some of the more common source filters
  1565.  
  1566. - Some additional checks for blessing things into various Statement
  1567. and Structure subclasses.
  1568.  
  1569. =head1 SUPPORT
  1570.  
  1571. See the L<support section|PPI/SUPPORT> in the main module.
  1572.  
  1573. =head1 AUTHOR
  1574.  
  1575. Adam Kennedy E<lt>adamk@cpan.orgE<gt>
  1576.  
  1577. =head1 COPYRIGHT
  1578.  
  1579. Copyright 2001 - 2010 Adam Kennedy.
  1580.  
  1581. This program is free software; you can redistribute
  1582. it and/or modify it under the same terms as Perl itself.
  1583.  
  1584. The full text of the license can be found in the
  1585. LICENSE file included with this module.
  1586.  
  1587. =cut
  1588.